home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / arrow.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  10.0 KB  |  345 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # manage "arrows", the row/column indicators
  8. # Each grid has a set of corrosponding row and column arrows that
  9. # track the row and column sizes for that grid.  The arrow for each grid
  10. # share the same "skinny" canvas-es and use canvas tags to identify
  11. # each arrow group. Each arrow has 2 tags: the identifier for the arrow's
  12. # group, and the group with a _nn suffix, where "nn" is the row or col #
  13.  
  14. # Update the arrow positions
  15. # Each arrow is updated to match the length of its 
  16. # corrosponding row/col
  17. # This gets called often, so it should be fast
  18. #  base:     The base name for the arrow canvases, as in ${base}_row...
  19. #  master:     The name of the table, which is also the tag name
  20.  
  21. proc arrow_update {base master} {
  22.     global P
  23.     upvar #0 geom:$master d
  24.  
  25.     set center 5
  26.     set tag tag:$master
  27.     for {set x1 2;set x2 3} {[info exists d(column_$x2)]} {incr x1 2;incr x2 2} {
  28.         ${base}_column coords ${tag}_$x1 $d(column_$x1) $center $d(column_$x2) $center
  29.     }
  30.     for {set x1 2;set x2 3} {[info exists d(row_$x2)]} {incr x1 2;incr x2 2} {
  31.         ${base}_row coords ${tag}_$x1 $center $d(row_$x1) $center $d(row_$x2)
  32.     }
  33.  
  34.     # now update the offsets, if any
  35.  
  36.     if {$master != ".can.f"} {
  37.         set dx [expr [winfo rootx $master.@0] - [winfo rootx .can.f] + 2*$P(grid_size)]
  38.         set dy [expr [winfo rooty $master.@0] - [winfo rooty .can.f] + 2*$P(grid_size)]
  39.         dputs offset: $dx,$dy
  40.         arrow_offset $base column $master $dx
  41.         arrow_offset $base row $master $dy
  42.     }
  43. }
  44.  
  45. # activate a set of arrows.This affects the arrows visibility and bindings
  46. #  base:  The base of the canvas name (e.g. .can)
  47. #  win:   Which set of arrows to activate
  48. #  color: What color to make the activated arrows
  49.  
  50. set Arrow_move 0
  51. proc arrow_activate {base master {color grey}} {
  52.     global P
  53.     set tag tag:$master
  54.     dputs $master
  55.     arrow_update $base $master    ;# this is overkill: find the bug!
  56.     foreach i {row column} {
  57.         ${base}_$i itemconfigure all -fill [${base}_$i cget -bg]
  58.         ${base}_$i bind all  <$P(button)> {}
  59.         ${base}_$i bind $tag  <$P(button)> {
  60.             set Arrow_move 1
  61.             set Dy [expr {[winfo rooty .can] - [winfo rooty .can.f]}]
  62.             set Dx [expr {[winfo rootx .can] - [winfo rootx .can.f]}]
  63.         }
  64.         ${base}_$i bind $tag  <ButtonRelease-$P(button)> "arrow_unhit %W $i %x %y"
  65.         ${base}_$i bind $tag  <B$P(button)-Motion> "arrow_move %W $i %x %y"
  66.         ${base}_$i itemconfigure $tag -fill $color
  67.         ${base}_$i raise $tag
  68.     }
  69. }
  70.  
  71. # This gets called from the button-release binding of an arrow as:
  72. # arrow_unhit %W [row|column] %x %y
  73.  
  74. proc arrow_unhit {win what x y} {
  75.     global Arrow_move Frames No_hit
  76.     set Arrow_move 0
  77.  
  78.     # re-sized a row/column - we had all this info, then lost it.  Oh well.
  79.     # 'tis all broken
  80.  
  81.     if {$No_hit} {
  82.         set tag [lindex [$win gettags [$win find withtag current]] 1]
  83.         regexp {tag:([^_]*)_(.*)} $tag dummy master index
  84.         upvar #0 [winfo name $master] data
  85.         set index [expr $index / 2 - 1]
  86.         set data(min_$what) [lreplace $data(min_$what) $index $index $No_hit]
  87.         set No_hit 0
  88.         foreach frame [array names Frames] {
  89.             update_table $frame arrow_move
  90.         }
  91.  
  92.     # toggled row/column state
  93.  
  94.     } else {
  95.         arrow_hit $win $what $x $y
  96.     }
  97. }
  98.  
  99. # change the offset of a set of arrow, for sub-frames
  100. # this interface is temporary
  101. #  base: .can
  102. #  what: "row" or "column"
  103. #  tag:  which table
  104. #  offset:  Offset from the beginning (defaults to 0)
  105.  
  106. proc arrow_offset {base what master {offset 0}} {
  107.     set tag tag:$master
  108.     set coords [${base}_$what coords $tag]
  109.     dputs   $tag <$coords> offset=$offset"
  110.     if {$what == "row"} {
  111.         ${base}_row move $tag 0 [expr $offset - [lindex $coords 1]]
  112.     } else {
  113.         ${base}_column move $tag [expr $offset - [lindex $coords 0]] 0
  114.     }
  115. }
  116.  
  117.  
  118. # delete an arrow from the end of the table
  119. # it should suffice to delete the last tag, but only if we're careful
  120. # to maintain the relative stacking order of all arrows with "tag"
  121. #  base: The base of the canvas name (e.g. .can)
  122. #  what: Row or Column
  123. #  master:  Which frame
  124. #  all:  delete the last arrow, or all of them
  125. # return value:  The name of the tag deleted, or ""
  126.  
  127. # This should return the tag of the arrow deleted, so the caller can
  128. # unset "Current", if any
  129.  
  130. proc arrow_delete {base what master {all ""}} {
  131.     global Current
  132.     set can ${base}_$what
  133.     set tag tag:$master
  134.     if {$all != ""} {
  135.         $can delete $tag
  136.         return ""
  137.     } else {
  138.         set all_tags [lindex [$can find withtag $tag] end]
  139.         set tag [lindex [$can gettag $all_tags] end]
  140.         $can delete $tag
  141.         dputs  $tag ($Current($what))
  142.         return $tag
  143.     }
  144. }
  145.  
  146. # set the shape of an arrow
  147. #  can:  the root of the canvas (e.g. can_$what)
  148. #  master:  Which table the arrow belongs to
  149. #  what:  "row" or "column"
  150. #  index: which arrow
  151. #  value:    true if <->, otherwise |-|
  152.  
  153. proc arrow_shape {can master what index value} {
  154.     global Current
  155.     set Current(dirty) 2
  156.     set tag tag:${master}_$index
  157.     if {$value} {    
  158.         set shape {4 10 4}
  159.         blt_table $what $master configure $index -resize both
  160.     } else {
  161.         set shape {4 0 4}
  162.         blt_table $what $master configure $index -resize none
  163.     }
  164.     dputs $master $what $value
  165.     ${can}_$what itemconfigure $tag -arrowshape $shape
  166. }
  167.  
  168. # reshape all the arrows, based on the table's resize property
  169.  
  170. proc arrow_shapeall {can master what} {
  171.     upvar #0 [winfo name $master] data
  172.     set list $data(resize_$what)
  173.     set index 0
  174.     dputs $master $what: $list
  175.     foreach arrow $list {
  176.         if {$arrow > 1} {    
  177.             set shape {4 10 4}
  178.             set resize both
  179.         } else {
  180.             set shape {4 0 4}
  181.             set resize none
  182.         }
  183.         set tag tag:${master}_[incr index 2]
  184.         dputs "${can}_$what itemconfigure $tag -arrowshape $shape"
  185.         ${can}_$what itemconfigure $tag -arrowshape $shape
  186.         blt_table $what $master configure $index -resize $resize
  187.     }
  188. }
  189.  
  190. # create a new arrow
  191. # This doesn't happen often (except, perhaps,  at startup)
  192. #  can: name of the canvas
  193. #  what: "row" or "column"
  194. #  master: The table master
  195. #  index:  MUST be even or "all" or ""
  196. #  value:  what shape: <=1 -> no resize, >=2 -> resize
  197.  
  198. # the "value" option is never used
  199.  
  200. proc arrow_create {can what master {index ""} {value ""}} {
  201.     global P
  202.     set tag tag:$master
  203.     upvar #0 geom:$master d
  204.  
  205.     # create all of the arrows
  206.  
  207.     dputs $master $what $index
  208.     if {![winfo exists $can]} {return 0}
  209.     if {$index == "all"} {
  210.         set max $d(${what}s)
  211.         incr max -1
  212.         set shape 0
  213.         $can delete $tag
  214.         dputs "new" $what $max
  215.         for {set indx 2} {$indx < $max} {incr indx 2; incr shape} {
  216.             arrow_create $can $what $master $indx [lindex $value $shape]
  217.         }
  218.     $can itemconfigure $tag -fill [$can cget -bg]
  219.     return 1
  220.  
  221.     # create the "next" arrow, get the resize behavior right (or try to)
  222.  
  223.     } elseif {$index == ""} {
  224.         set index [expr [llength [$can find withtag $tag]] * 2 + 2]
  225.         upvar #0 [winfo name $master] data
  226.         set value [lindex  $data(resize_$what) end]
  227.     }
  228.  
  229.     set x1 $index
  230.     set x2 [incr index]
  231.     array set pick {row "0 3" column "1 4"}
  232.     set coords [ eval "lrange {5 $d(${what}_$x1) 5 $d(${what}_$x2) 5} $pick($what)"]
  233.     if {$value != "" && $value > 1} {    
  234.         set shape {"4 10 4"}
  235.         set reshape both
  236.     } else {
  237.         set shape {"4 0 4"}
  238.         set reshape none
  239.     }
  240.     set options "-width 3 -arrow both -arrowshape $shape -fill $P(grid_color) \
  241.             -tags \"$tag ${tag}_$x1\""
  242.  
  243.     eval $can create line $coords $options
  244.     $can bind ${tag}_$x1  <Enter> "$can configure -cursor hand1"
  245.     $can bind ${tag}_$x1  <Leave> "$can configure -cursor {}"
  246.     blt_table $what $master configure $x1 -resize $reshape
  247.     return 1
  248. }
  249.  
  250. # Process a button hit on an arrow.  This is invoked via bind
  251. # If the arrow is "current", toggle its resize mode, otherwise make it
  252. # the current arrow
  253. #   win:    the window receiving the event (%W)
  254. #   what:    "row" or "column"
  255. #   color:    The color to highlight the arrow
  256.  
  257. proc arrow_hit {win what x y {color red}} {
  258.     global Current No_hit X0 Y0
  259.     set X0 $x; set Y0 $y
  260.     set master none
  261.     set tag [lindex [$win gettags [$win find withtag current]] 1]
  262.     regexp {tag:([^_]*)_(.*)} $tag dummy master index
  263.     if {$master == "none"} return
  264.     dputs "$master $what $index ($tag)"
  265.     unselect_widget
  266.     if {$tag == $Current($what)} {
  267.         arrow_shape .can $master $what $index \
  268.                 [expr [resize_set $master $what $index] > 1]
  269.     } else {
  270.         arrow_highlight $what $master $index $color
  271.     }
  272. }
  273.  
  274. # sweep out a row or column, changing its size
  275. # Only sweep if we're near the right edge of the arrow
  276. # (I'm re-computing too much stuff here)
  277.  
  278. proc arrow_move {win what x y} {
  279.     if {[button_gravity $x $y 5]} {return}
  280.     
  281.     global No_hit P _Message Current Dx Dy
  282.     set Current(dirty) 1
  283.     if {!$No_hit} {
  284.         unselect_widget
  285.         incr No_hit
  286.     }
  287.     array set map1 {row -height column -width}
  288.     array set map2 {row y column x}
  289.     array set map3 {row 1 column 0}
  290.     set tag [lindex [$win gettags [$win find withtag current]] 1]
  291.     incr x $Dx
  292.     incr y $Dy
  293.     dputs $win $what $x,$y <[expr [winfo rooty .can.f] - [winfo rooty .can]]> ($tag)
  294.     regexp {tag:([^_]*)_(.*)} $tag dummy master index
  295.     upvar #0 geom:$master data
  296.     set offset [lindex [$win coords tag:$master] $map3($what)]
  297.     set width [expr int([set $map2($what)] - $data(${what}_$index) - \
  298.             $offset +$P(grid_size))]
  299.     dputs width $width
  300.     if {$width < 5} return
  301.     set No_hit $width        ;# hmmm
  302.     set _Message "$what [expr $index/2] size $width"
  303.     blt_table $what $master configure $index $map1($what) "$width Inf"
  304.     # arrow_update .can $master
  305.     # update idletasks
  306. }
  307.  
  308. # unselect the "current" row or column indicator
  309. # what: "row" or "column"
  310.  
  311. proc arrow_unhighlight {what} {
  312.     global Current P
  313.     if {$Current($what) != ""} {
  314.         .can_$what itemconfigure $Current($what) -fill $P(grid_color)
  315.         set Current($what) ""
  316.     }
  317. }
  318.  
  319.  
  320. # highlight an arrow
  321. #  what: "row" or "column"
  322. #  tag:  which set of arrows (the table master)
  323. #  index: which arrow in the set
  324. #  color: What color to make the arrow
  325.  
  326. proc arrow_highlight {what master index color} {
  327.     global Current
  328.     dputs $master $index $color
  329.     arrow_unhighlight $what
  330.     set tag tag:$master
  331.     .can_$what itemconfigure ${tag}_$index -fill $color
  332.     set Current($what) ${tag}_$index
  333. }
  334.  
  335. # zap all arrows!
  336.  
  337. proc arrow_zapall {base} {
  338.     dputs $base
  339.     ${base}_row delete all
  340.     ${base}_column delete all
  341. }
  342.  
  343. set Current(row) ""            ;# the currently selected row tag
  344. set Current(column) ""        ;# the currently selected column tag
  345.